{-# LANGUAGE OverloadedStrings, FlexibleContexts, ScopedTypeVariables #-}

import Network
import Network.Browser
import Network.HTTP -- cabal install HTTP; doesn't lazy download, consider minihttp
import Text.HTML.TagSoup -- cabal install tagsoup;  consider http://hackage.haskell.org/packages/archive/HaXml/1.20.2/doc/html/Text-XML-HaXml-Html-ParseLazy.html or http://www.haskell.org/haskellwiki/HXT
-- consider http://hackage.haskell.org/package/tagsoup-parsec

import Text.Parsec hiding ((<|>),many) -- parsec 3; 'cabal upgrade parsec' doesn't get it, cuz 2.1 is still 'preferred' -- use 'cabal install parsec-3.1.0'
import Text.Parsec.ByteString

import qualified Data.ByteString.Char8 as B -- .Lazy has no isInfixOf or breakSubstring or findSubstring, must be reason why...
import qualified Data.ByteString.Lazy as L

import Data.List
import Data.Char
import qualified Data.Map as M
import Data.Either
import Data.Function
import Data.String
import qualified Data.Traversable as T

import Control.Applicative
import Control.Monad
import Control.Arrow
import qualified Control.Exception as E

-- import Paths_logsPkg
import Data.Binary
import Codec.Compression.GZip
import System.Directory
import System.IO.PlafCompat -- cabal install MissingH
import qualified System.IO.Error as I
import Control.DeepSeq

{-
TODO:
try lazy http library
parallel download (can't use Control.Parallel -- requires referential transparency, would be very hard to parallelize Network.Browser)

why do lazy ByteStrings lack functions like isInfixOf, unzip, sort, hPutStr, getLine?

why does  Network.Brower.request parameterize Request and Response on the same type? (HStream ty => Request ty -> BrowserAction (HandleStream ty) (URI, Response ty))
	and why does Network.HTTP.getRequest hardcode the parameter as String?  together, these mean they don't play well with ByteStrings and a little modifier has to be written.

why does Text.Parsec.Combinator.manyTill hardcode [a] as the output? (ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m [a])  since i use it with anyChar a lot, this means it doesn't play well with ByteStrings.
	i have to write a little converter (ByteString.pack <$>), which probably kills the whole point of using ByteStrings in the first place.




problem files (verified really in data):
06.09.28 - "07:ite"
09.07.22 - "08:32:52 -08:33:13 <Berengal> ray: God, I wish haskell could compile to jvm..."


some only seem to have partial days:
08.02.25 - usrs:39
09.04.15 - usrs:45

09.09.29 - usrs:41
09.09.30 cmds:32 msgs:0 usrs:0
09.10.01 cmds:28 msgs:0 usrs:0
09.10.02 cmds:26 msgs:0 usrs:0

10.01.17 cmds:18 msgs:0 usrs:0
10.01.18 cmds:14 msgs:0 usrs:0
10.01.19 cmds:29 msgs:0 usrs:0
10.01.20 cmds:264 msgs:612 usrs:35



short day, good for manual checks:
06.03.07 cmds:19 msgs:9 usrs:4
-}

data MsgType = Action | Message | Notice | Command deriving (Show, Eq, Ord)
instance Binary MsgType where
      put Action  = putWord8 0
      put Message = putWord8 1
      put Notice  = putWord8 2
      put Command = putWord8 3
      get = do
        t <- getWord8
        case t of
          0 -> return Action
          1 -> return Message
          2 -> return Notice
          3 -> return Command

data Command = Nick | Quit | Join | Log | Part | Mode | Topic | Names | Kick deriving (Enum,Show,Bounded,Eq)
type Name = B.ByteString
data LineType = Cmd Command | Msg MsgType Name deriving (Show,Eq)
type Timestamp = (Int,Int,Int) -- why can't i have: (Read a, Integral a) => (a,a,a)

data MsgRec = MsgRec {
    year    :: Int -- why can't i have these Ints as : Integral a => a
  , month   :: Int
  , day     :: Int
  , hour    :: Int
  , minute  :: Int
  , sec     :: Int
  , nick    :: Name
  , msgType :: MsgType
  , cargo   :: B.ByteString
  } deriving (Show)
{-
instance Binary MsgRec where
 put (MsgRec y m d h min s n mt c) = put y >> put m >> put d >> put h >> put min >> put s >> put n >> put mt >> put c
 get = MsgRec <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
-}

(<<) = flip (>>)
($!!) f x = x `deepseq` f x

(>*>) :: (Applicative f, Monad m) => f (m a) -> f (m b) -> f (m b)
(>*>) = liftA2 (>>) -- thx FunctorSalad

-- must be a better way than this!
unlessM :: (Monad m, Functor m) => (a -> Bool) -> (a -> m ()) -> m a -> m ()
unlessM p f x = do t <- p <$> x
                   if t then return () else (f =<< x)

isEmptyError :: E.SomeException -> Bool -- why no predicate for empty list exceptions?  why can't this be forall a. (E.Exception a) => a -> Bool?
isEmptyError = isInfixOf "empty list" . show

safeList :: NFData b => ([a] -> b) -> [a] -> IO (Maybe b)
safeList f xs = (const Nothing ||| Just) <$> E.tryJust (guard . isEmptyError) (return $!! f xs) -- Heffalump @ #haskell fixed the laziness problem

main :: IO ()
main = withSocketsDo $ do
      let getDataFileName _ = return "/Users/eflister/Desktop/h1ccup/h1ccup/trunk/theory/haskell/src/logsPkg/idx/" -- temporary, cuz leksah doesn't actually make .cabal/share/logsPkg-0.0.1/
      dataDir <- getDataFileName "idx"

      let url = "http://tunes.org/~nef//logs/haskell/"

          dateFilt :: Timestamp -> Bool
          dateFilt (y,m,d) = y == 10 -- && m == 7
          -- dateFilt (y,m,d) = True

          usrFilt :: Name -> Bool
          -- usrFilt = (== "twey")
          usrFilt = const True

          cargoFilt :: B.ByteString -> Bool
          -- cargoFilt = B.isInfixOf "þ" . B.map toLower
          -- cargoFilt = B.isInfixOf "midi" . B.map toLower
          cargoFilt = const True

          getFiles = parseFilt (timestamp ".") . map B.pack <$> (filterM ((not . isDirectory <$>) . getFileStatus . (dataDir ++)) =<< getDirectoryContents dataDir << createDirectoryIfMissing True dataDir)

          latest :: Ord b => [(B.ByteString,b)] -> FilePath               
          latest = (dataDir ++) . B.unpack . fst . maximumBy (compare `on` snd)

          getLinks           = map (fromAttrib "href") . filter (isTagOpenName "a") . canonicalizeTags . parseTags
          parseFilt p        = rights . map (\x -> (Left ||| \y -> Right (x,y)) $ parse p "" x)
          mergeAndSort       = sortBy ((flip compare) `on` length . snd) . M.toList . M.unionsWith (++)
          process            = ((return $!) . prune usrFilt cargoFilt cargo =<<) . doFile dataDir -- ddarius @ #haskell fixed the space leak
          usrRpt x           = do putStrLn $ (B.unpack . fst) x ++ ":" ++ (show . length $ snd x)
                                  mapM_ (\y -> putStrLn $ "\t" ++ show ([year,month,day,hour,minute,sec] <*> [y]) ++ " " ++ (show $ msgType y) ++ " :\t" ++ (B.unpack . cargo) y) $ snd x
          subRpt x           = putStrLn $ (show . sum $ map (length . snd) x) ++ " messages from " ++ (show $ length x) ++ " usrs"

      -- most recent file is probably partial
      T.traverse removeFile =<< safeList latest =<< getFiles
      -- unlessM null (removeFile . (dataDir ++) . latest) getFiles

      files <- getFiles
      browse $ do
          setOutHandler . const $ return ()
          mapM_ (doPage url dataDir) =<< (\\ files) . parseFilt (timestamp ".") . getLinks <$> getUrl url

      all <- mergeAndSort <$> (mapM (((subRpt . M.toList) >*> return) <=< process) =<< filter (dateFilt . snd) <$> getFiles)

      subRpt all
      -- mapM_ usrRpt all

prune :: Ord k => (k -> Bool) -> (w -> Bool) -> (v -> w) -> M.Map k [v] -> M.Map k [v]
prune keyFilt valFilt sel map = M.foldWithKey (\k _ -> M.update f k) m m
   where m   = M.filterWithKey (const . keyFilt) map
         f v = if (not . null $ vs) then Just vs else Nothing
           where vs = filterBy sel valFilt v

type HS = HandleStream B.ByteString -- why can't i have: HStream h => HandleStream h

getUrl :: B.ByteString -> BrowserAction HS (B.ByteString)
getUrl = (rspBody . snd <$>) . request . rbs . getRequest . B.unpack

-- since Network.HTTP.getRequest :: Request String and Network.Brower.request :: HStream ty => Request ty -> BrowserAction (HandleStream ty) (URI, Response ty), ByteStrings need a modified geRequest
-- rbs :: IsString a => Request a -> Request B.ByteString -- why doesn't this work?
-- rbs x = x {rqBody = B.pack . fromString $ rqBody x}
rbs :: Request String -> Request B.ByteString
rbs x = x {rqBody = B.pack $ rqBody x}

w :: Integral a => a -> Word8
w = fromIntegral

doFile :: FilePath -> (B.ByteString,Timestamp) -> IO (M.Map Name [MsgRec])
doFile dataDir (file,(y,m,d)) = do
           let f      = B.unpack file
               uncDir = dataDir ++ "uncompressed/"
               unc    = uncDir ++ f

           putStr f
           createDirectoryIfMissing True uncDir
           xs :: [(Name,[(Word8, Word8, Word8, MsgType, B.ByteString)])] <- decode <$> 
            (((const ((decompress <$> (L.readFile $ dataDir ++ f)
                      ) >>= (const $ putStr " c ") >*> L.writeFile unc >*> return
                     )
              ) 
               ||| 
              ((const $ putStr " u ") >*> return)
             ) =<< (E.tryJust (guard . I.isDoesNotExistError) $ L.readFile unc)
            )
           return . M.fromList $ map (\(n,rs) -> (n, map (\(h,mn,s,t,c) -> MsgRec {year=y, month=m, day=d, hour=fromIntegral h, minute=fromIntegral mn, sec=fromIntegral s, nick=n, msgType=t, cargo=c}) rs)) xs

doPage :: B.ByteString -> FilePath -> (B.ByteString,Timestamp) -> BrowserAction HS (M.Map Name [MsgRec])
doPage baseUrl dataDir (file,tmstmp) = do
      (errs, categorized) <- analyze tmstmp . B.lines <$> (getUrl $ baseUrl `B.append` file)
      let lookup t = M.findWithDefault [] t categorized
          msgs     = lookup Message
          count    = show . length . lookup
          all      = categorizeOn nick $ msgs ++ lookup Action ++ lookup Notice
      ioAction . putStrLn $ (B.unpack file) ++ " nots:" ++ count Notice ++ "\t acts:" ++ count Action ++ "\t cmds:" ++ count Command ++ "\t msgs:" ++ (show $ length msgs) ++ "\t usrs:" ++ (show . M.size $ all)
      ioAction . mapM_ (\x -> putStrLn ("couldn't parse: " ++ x) >> putStrLn "") $ map show errs
      ioAction . L.writeFile (dataDir ++ B.unpack file) . compressWith defaultCompressParams {compressLevel = bestCompression} . encode . map (\(k,vs) -> (k,map (\v -> (w $ hour v, w $ minute v, w $ sec v, msgType v, cargo v)) vs)) $ M.toList all 
      return all

analyze :: Timestamp -> [B.ByteString] -> ([ParseError], M.Map MsgType [MsgRec])
analyze (year,month,day) lines = (errs, categorized)
  where (errs,goods) = partitionEithers $ map (\x -> parse logLine (B.unpack x) x) lines
        categorized  = categorizeOn msgType $ map makeRec goods

        makeRec ((hour,minute,sec),linetype,cargo) = MsgRec {year=fromIntegral year, month=fromIntegral month, day=fromIntegral day, hour=hour, minute=minute, sec=sec, nick=getName linetype, msgType=getType linetype, cargo=cargo}

        getName (Msg _ n) = B.map toLower $ removeTrailing '_' n
           where removeTrailing c = B.reverse . B.dropWhile (== c) . B.reverse
        getName _         = undefined

        getType (Msg t _) = t
        getType (Cmd _)   = Command

filterBy :: (a -> b) -> (b -> Bool) -> [a] -> [a]
filterBy c f = concatMap (\x -> if f $ c x then [x] else [])

categorizeOn :: Ord b => (a -> b) -> [a] -> M.Map b [a]
categorizeOn f = M.fromListWith (++) . map (\x -> (f x,[x])) -- thx kmc@ #haskell

skip :: Parser a -> Parser ()
skip = (() <$)

tryChoice :: [Parser a] -> Parser a
tryChoice = choice . map try

logLine :: Parser (Timestamp,LineType,B.ByteString)
logLine = (,,) <$> (timestamp ":" <*) space <*> lineType <*> strTill eof

strTill :: (Stream s m Char) => ParsecT s u m end -> ParsecT s u m B.ByteString
strTill = fmap B.pack . manyTill anyChar
-- needed cuz manyTill::(ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m [a]) probably kills all advantages of using ByteStrings!
-- quicksilver @ #haskell sez: If the strings are relatively short (say, under 16K) then the re-packing into bytestring happens in-cache and it probably doesn't matter.
-- Saizan suggests writing Parser a -> Parser Bytestring by keeping track of the state before and after, and doing a take directly into the source Bytestring

lineType :: Parser LineType
lineType = tryChoice [Cmd <$> cmd, Msg Notice <$> msg ('-','-'), Msg Message <$> msg ('<','>'), Msg Action <$> action] -- order matters: cmd must be before notice, because otherwise "---" looks like the nick "-" for notices

msg :: (Char,Char) -> Parser Name
msg (a,b) = (char a) *> (strTill . try . string $ b : " ") <?> "<nick>" -- wtf? why doesn't between do this?  this try is lame -- why doesn't manyTill do it?

action :: Parser Name
action = char '*' *> space *> strTill (skip space <|> eof) <?> "* nick" -- eof doesn't get consumed

cmd :: Parser Command
cmd = (count 3 $ char '-') *> space *> cmdType <* (string ": ") <?> "--- status:"

cmdType :: Parser Command
cmdType = tryChoice $ map enum ([minBound .. maxBound]::[Command])
	where enum s = s <$ string (map toLower $ show s)

timestamp :: String -> Parser Timestamp
timestamp sep = tup . map read <$> chunkSep 3 (count 2 digit) (string sep) <?> "timestamp"
	where tup [a,b,c] = (a,b,c)

chunkSep :: Integral n => n -> Parser [a] -> Parser [a] -> Parser [[a]]
chunkSep n chunk sep | n <= 0    = return empty
                     | otherwise = filter (not . null) <$> (sequence . intersperse (empty <$ sep) $ genericReplicate n chunk)
